home *** CD-ROM | disk | FTP | other *** search
/ The Business Master (3rd Edition) / The Business Master (3rd Edition).iso / files / datature / omahadb / create.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1985-06-08  |  16.3 KB  |  294 lines
  1. 1000  REM ***** CREATE PROGRAM ******
  2. 1005  OPEN "DD" FOR INPUT AS 1: INPUT #1,DR$:CLOSE
  3. 1010  'ON ERROR GOTO 30000
  4. 1020  DIM U%(22):FOR I=0 TO 21:READ U%(I):NEXT:DATA&H8B55,&HB8EC,&H0600,&H07B7,&H768B,&H8A0C,&H8B2C,&HA76,&HC8A,&H768B,&H8A08,&H8B34,&H676,&H148A,&HCDFE,&HC9FE,&HCEFE,&HCAFE,&H10CD,&HCA5D,&H8,&H0
  5. 1040  DEF FNPN(S)=CVI(MID$(P$,S*2-1,2))
  6. 1050  IF CHR$(SCREEN(2,27))<>"T" THEN CLS: COLOR 0,7:PRINT SPACE$(240):LOCATE 2,27:PRINT "The Omaha DataBase Program":LOCATE 1,1:PRINT"KEY";STRING$(78,"THEN");"CLOSE":LOCATE 2,1:PRINT "OPEN":LOCATE 2,80:PRINT "OPEN":LOCATE 3,1:PRINT "SCREEN";STRING$(78,"THEN");"LOAD": COLOR 7,0
  7. 1060  KEY OFF:FOR G=1 TO 10:KEY G,"":NEXT
  8. 1070  DIM X$(2,70),T$(6,70),BB(6,70),BL(6,70),T(6,70)
  9. 1080  GOSUB 1120
  10. 1090  LOCATE 2,3:PRINT TIME$:LOCATE 2,69:PRINT DATE$
  11. 1100  TIMER ON: ON TIMER (1) GOSUB 10000
  12. 1110  GOSUB 1120: GOTO 2000
  13. 1115  R1%=6:R2%=16:C1%=1:C2%=80:GOTO 1150: REM SCREEN CLEAR
  14. 1120  R1%=4:R2%=24:C1%=1:C2%=80:GOTO 1150: REM SCREEN CLEAR
  15. 1130  R1%=4:R2%=19:C1%=1:C2%=80:GOTO 1150: REM SCREEN CLEAR
  16. 1140  R1%=21:R2%=23:C1%=2:C2%=78:GOTO 1150: REM BOX CLEAR
  17. 1150  DEF SEG: SUBRT%=VARPTR(U%(0)):CALL SUBRT%(R1%,C1%,R2%,C2%):RETURN
  18. 1160  LOCATE 20,1: PRINT "KEY";STRING$(77,"THEN");"CLOSE":LOCATE 21,1:PRINT "OPEN":LOCATE 21,79:PRINT "OPEN":LOCATE 22,1:PRINT "OPEN":LOCATE 22,79:PRINT "OPEN":LOCATE 23,1:PRINT"OPEN":LOCATE 23,79:PRINT"OPEN";:LOCATE 24,1:PRINT "SCREEN";STRING$(77,"THEN");"LOAD";:RETURN:REM BOX
  19. 1170  REM FORMAT FILE
  20. 1180  F$=DR$+":FORMAT"
  21. 1190  OPEN F$ FOR INPUT AS #7:
  22. 1200  FOR F=0 TO 6:IF EOF(7) THEN 1210 ELSE INPUT #7,F$(F),LL(F),TE(F),DR$(F):FOR Y=1 TO TE(F):INPUT #7,T$(F,Y),T(F,Y),BB(F,Y),BL(F,Y):NEXT:NEXT
  23. 1210  CLOSE:TF=F-1
  24. 1220  RETURN
  25. 1230  PLAY "MB":FOR I9=1 TO 3:FOR J9=2 TO 4:PLAY "L64T255O=J9;CC#DD#EFF#GG#AA#B":NEXT:NEXT:RETURN
  26. 1240  PLAY "MB":FOR I9=1 TO 6:FOR J9=2 TO 4:PLAY "L64T255O=J9;D#EFF#GG#A":NEXT:NEXT:RETURN
  27. 1250  PLAY "MB":FOR I9=1 TO 8:FOR J9=2 TO 4:PLAY "L64T200O=J9;DEFGA":NEXT:NEXT:RETURN
  28. 1260  LOCATE 23,3: COLOR 15:PRINT "INCORRECT ENTRY":COLOR 7,0:GOSUB 1250:GOSUB 1250:GOSUB 1140:RETURN
  29. 2000  REM START OF THE PROGRAM
  30. 2010  GOSUB 1120
  31. 2020  RESTORE 2030
  32. 2030  DATA F1  CREATE NEW MASTER FILE,F2  CREATE NEW SUB FILE,F3  REVISE MASTER/SUB FILE,F4  DELETE SUB-FILE,F5  PRINT FILE FORMAT,,,,,F10 EXIT
  33. 2040  LOCATE 6,25:COLOR 25: PRINT "PRESS FUNCTION KEY FOR CHOICE":COLOR 7,0
  34. 2050  FOR G=1 TO 10:READ X$:LOCATE 9+G,25:PRINT X$:NEXT
  35. 2060  CH$=INKEY$: IF CH$="" THEN 2060
  36. 2070  IF ASC(LEFT$(CH$,1))=0 THEN 2090
  37. 2080  BEEP:GOTO 2110
  38. 2090  CH=ASC(MID$(CH$,2)): CH=CH-58:CHO=CH
  39. 2100  ON CH GOTO 3000,4000,5000,6000,7000,2110,2110,2110,2110,8000
  40. 2110  BEEP: LOCATE 23,25: COLOR 9:PRINT "INCORRECT CHOICE":COLOR 7,0:FOR G=1 TO 1000:NEXT:LOCATE 23,25: PRINT "                  ":GOTO 2060
  41. 3000  REM CREATE NEW MASTER FILE
  42. 3010  F=0
  43. 3020  GOSUB 1120
  44. 3030  GOSUB 1160
  45. 3040  LOCATE 6,1:COLOR 9:PRINT "IMPORTANT NOTICE":COLOR 7,0
  46. 3050  LOCATE 8,1:PRINT "Make sure that your program disk is in the active drive."
  47. 3060  PRINT :PRINT "This routine will erase the format file on the program disk."
  48. 3080  PRINT "This routine is to be used only when you are first STARTING your file. If you   have reached this routine in ERROR then do not enter the correct access code    and you will be returned to the main menu."
  49. 3090  LOCATE 21,3: COLOR 15:BEEP:PRINT "ENTER 'CREATION' AS AN ACCESS CODE TO CONTINUE ===> ";:COLOR 7,0:INPUT AN$
  50. 3100  IF AN$<>"creation" AND AN$<>"CREATION" THEN LOCATE 22,3:PRINT "INVALID ACCESS CODE, RETURN TO MENU":GOSUB 1250: GOTO 2000
  51. 3110  LOCATE 22,3:PRINT "VALID ACCESS CODE": GOSUB 1130
  52. 3120  GOSUB 1140
  53. 3130  LOCATE 6,1:COLOR 9: PRINT "MASTER FILE":COLOR 15
  54. 3140  LOCATE 8,1: PRINT "MASTER FILE NAME "
  55. 3150  LOCATE 9,1:PRINT "DRIVE FOR FILE"
  56. 3160  LOCATE 10,1: PRINT "NUMBER OF FIELDS"
  57. 3170  LOCATE 11,1:PRINT "LENGTH OF EACH RECORD"
  58. 3180  COLOR 7,0
  59. 3190  BEEP: LOCATE 21,3: PRINT "Please type in the name for the Master File (no longer than 8 spaces!)."
  60. 3200  LOCATE 22,3: INPUT "The name of the Master File is ===> ";F$(F)
  61. 3210  IF LEN(F$(F))>8 THEN GOSUB 1260:GOTO 3190
  62. 3220  IF VAL(MID$(F$(F),1,1))<>0 THEN GOSUB 1260:GOTO 3190
  63. 3230  LOCATE 8,30:PRINT F$(0)
  64. 3240  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the letter of the drive that will have the data disk.":LOCATE 22,3:INPUT "Type either A or B (or C if you have a hard disk drive) ==> ";DR$(0)
  65. 3250  IF INSTR("abcdefghABCDEFGH",DR$(0))=0 THEN GOSUB 1260: GOTO 3240
  66. 3260  IF LEN(DR$(0))>1 THEN 1260: GOTO 3240
  67. 3270  LOCATE 9,30:PRINT DR$(0)
  68. 3280  COLOR 9:LOCATE 13,1:PRINT "TITLE              TYPE      BEG.    LENGTH":COLOR 7,0
  69. 3290  Y=0
  70. 3300  LL(F) =4: IF F=0 THEN LL(F)=10
  71. 3310  Y=Y+1
  72. 3320  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the title for entry # ";Y" (only 10 spaces please)."
  73. 3330  LOCATE 22,3: PRINT "Title for entry # ";Y;" ";:INPUT T$(F,Y)
  74. 3340  IF T$(F,Y)="" THEN 3460
  75. 3350  IF LEN(T$(F,Y))>10 THEN GOSUB 1260:GOTO 3320
  76. 3360  LOCATE 14+((Y-1) MOD 3):PRINT T$(F,Y);STRING$(50,32): IF Y <>1 THEN BB(F,Y)=BB(F,Y-1)+BL(F,Y-1) ELSE IF F=0 THEN BB(F,Y)=11 ELSE BB(F,Y)=5
  77. 3370  GOSUB 1140: LOCATE 21,3:PRINT "Type of entry: (1) Alphabetic; (2) Number; (3) Date; (4) Dollars/cents": LOCATE 22,3: INPUT "Enter the type of entry ===> ";AN$:T(F,Y)=VAL(AN$)
  78. 3380  IF T(F,Y)<1 OR T(F,Y)>4 THEN GOSUB 1260: GOTO 3370
  79. 3390  LOCATE 14+((Y-1) MOD 3),20:PRINT MID$("ALPHA NUMBERDATE  00.00 ",1+((T(F,Y)-1)*6),6);
  80. 3400  IF T(F,Y)=3 THEN BL(F,Y)=6: GOTO 3430
  81. 3410  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the maximum number of spaces you wish reserved for this ": LOCATE 22,3: INPUT "entry ====> ";AN$:BL(F,Y)=VAL(AN$)
  82. 3420  IF BL(F,Y)=0 THEN GOSUB 1260: GOTO 3410
  83. 3430  LOCATE 14+((Y-1) MOD 3),30:PRINT BB(F,Y);:LOCATE ,40:PRINT BL(F,Y)
  84. 3440  TE(F)=TE(F)+1:LL(F)=LL(F)+BL(F,Y): LOCATE 10,29:PRINT TE(F):LOCATE 11,29:PRINT LL(F):
  85. 3450  GOTO 3310
  86. 3460  LL(F)=LL(F)+1
  87. 3470  F$=DR$+":FORMAT"
  88. 3480  IF CHO=1 THEN TF=0 ELSE TF=TF+1
  89. 3481  FI$=DR$+":REC":OPEN FI$ FOR OUTPUT AS #7: FOR X=1 TO 12:PRINT #7,"0":NEXT:CLOSE:
  90. 3490  OPEN F$ FOR OUTPUT AS #7: FOR F=0 TO TF: PRINT #7,F$(F):PRINT#7,LL(F):PRINT#7,TE(F):PRINT #7,DR$(F):FOR Y=1 TO TE(F):PRINT #7,T$(F,Y):PRINT#7,T(F,Y):PRINT#7,BB(F,Y):PRINT#7,BL(F,Y):NEXT:NEXT
  91. 3500  PRINT #7,CHR$(26):CLOSE
  92. 3510  RUN
  93. 4000  REM CREATE NEW SUB FILE
  94. 4010  GOSUB 1170: GOSUB 1120:GOSUB 1160
  95. 4020  IF F=>6 THEN LOCATE 22,3:PRINT "COMPUTER INDICATES THAT YOU HAVE 5 SUB-FILES ALREADY":GOSUB 1250:GOSUB 1250:RUN
  96. 4030  LOCATE 4,1:PRINT "Present Sub-Files:" :FOR G=1 TO F-1:PRINT F$(G);"  ";:NEXT:PRINT
  97. 4040  LOCATE 7,1:COLOR 9: PRINT "SUB-FILE":COLOR 15
  98. 4050  LOCATE 8,1: PRINT "SUB-FILE NAME "
  99. 4060  LOCATE 9,1:PRINT "DRIVE FOR FILE"
  100. 4070  LOCATE 10,1: PRINT "NUMBER OF FIELDS"
  101. 4080  LOCATE 11,1:PRINT "LENGTH OF EACH RECORD"
  102. 4090  COLOR 7,0
  103. 4100  BEEP: LOCATE 21,3: PRINT "Please type in the name for the Sub-File (no longer than 8 spaces!)."
  104. 4110  LOCATE 22,3: INPUT "The name of the Sub-File is ===> ";F$(F)
  105. 4120  IF LEN(F$(F))>8 THEN GOSUB 1260:GOTO 4100
  106. 4130  IF VAL(MID$(F$(F),1,1))<>0 THEN GOSUB 1260:GOTO 4100
  107. 4140  LOCATE 8,30:PRINT F$(F)
  108. 4150  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the letter of the drive that will have the data disk.":LOCATE 22,3:INPUT "Generally this would be A or B but can be from range A-H ==> ";DR$(F)
  109. 4160  IF INSTR("abcdefghABCDEFGH",DR$(0))=0 THEN GOSUB 1260: GOTO 4150
  110. 4170  IF LEN(DR$(F))>1 THEN 1260: GOTO 4150
  111. 4180  LOCATE 9,30:PRINT DR$(F)
  112. 4190  GOTO 4200
  113. 4200  REM ENTRY OF FILE DATA
  114. 4210  GOTO 3280
  115. 5000  REM REVISE MASTER/SUB FILE
  116. 5010  GOSUB 1170: GOSUB 1120:GOSUB 1160
  117. 5020  LOCATE 7,1:COLOR 9: PRINT "REVISE MASTER/SUB FILE":COLOR 7,0
  118. 5030  LOCATE 9,1: PRINT "This routine will allow you to change any aspect of the files you have created. You can revise the file name, field names, field length, field type, drive for  the file etc."
  119. 5040  PRINT "    If you are going to change the field length, the file (if it has records)   will have to be rewritten.  You may want to change the file and keep it or use  it to create a new file."
  120. 5050  PRINT "    Press the 'enter' key to retain the present value contained in the file. To delete an entry enter '0' for the number of spaces for that entry."
  121. 5060  COLOR 0,7:PRINT "    Make sure that you have made a duplicate copy of your data disk before you      begin this routine.  This routine once started, CANNOT be interrupted.      ":COLOR 7,0
  122. 5070  LOCATE 21,3: COLOR 15:PRINT "Type in 'REVISE' for the access code to proceed":COLOR 7,0:LOCATE 22,3:INPUT "Access Code ========>  ";AN$: IF AN$<>"REVISE" AND AN$<>"revise" AND AN$<>"Revise" THEN LOCATE 23,3: COLOR 31: PRINT "Access Denied" ELSE 5090
  123. 5080  COLOR 7,0: GOSUB 1250:GOSUB 1250: RUN
  124. 5090  LOCATE 23,3: COLOR 31: PRINT "Access Permitted":BEEP:BEEP: FOR G=1 TO 200:NEXT: COLOR 7,0
  125. 5100  GOSUB 1130:GOSUB 1140
  126. 5110  COLOR 9: LOCATE 6,1: PRINT "REVISE MASTER/SUB-FILE":COLOR 7,0
  127. 5120  LOCATE 8,1: PRINT "This routine will you to revise any file you choose. Currently you have these   files:"
  128. 5130  LOCATE 10,15: FOR G=0 TO TF:LOCATE ,15:PRINT G".  ";F$(G):NEXT
  129. 5140  LOCATE 21,3:PRINT "Type the number of the file you wish to revise "
  130. 5150  LOCATE 22,3:INPUT "Number of file to REVISE ===> ";AN$:CH=VAL(AN$)
  131. 5160  IF CH<1 AND AN$<>"0" OR CH>F-1 THEN GOSUB 1260:LOCATE 23,3:PRINT "ACCESS DENIED":GOSUB 1250:RUN
  132. 5170  GOSUB 1130:GOSUB 1140
  133. 5180  F$(6)=F$(CH):LL(6)=LL(CH):TE(6)=TE(CH):DR$(6)=DR$(CH):FOR Y=1 TO TE(CH):SWAP T$(6,Y),T$(CH,Y):SWAP T(6,Y),T(CH,Y):SWAP BB(6,Y),BB(CH,Y):SWAP BL(6,Y),BL(CH,Y):NEXT
  134. 5190  F=CH:LL(F)=4:TE(F)=0:IF F=0 THEN LL(F)=LL(F)+6
  135. 5200  COLOR 9:LOCATE 4,1:PRINT "FILE: ";F$(6);"     ENTRIES: ";TE(6);"   LENGTH: ";LL(6)"   DRIVE: ";DR$(6)
  136. 5210   COLOR 15:PRINT "#     TITLE          TYPE     BEGINNING         LENGTH"
  137. 5220  E1=1:GOTO 5240
  138. 5230  IF Y=>TE(6) THEN 5560
  139. 5235  E1=E2+1
  140. 5240  IF E1+10=>TE(6) THEN E2=TE(6) ELSE E2=E1+ 9
  141. 5250  GOSUB 1115:COLOR 9:FOR Y=E1 TO E2
  142. 5260  LOCATE 6+(Y MOD 11),1:PRINT Y".  ";LEFT$(T$(6,Y)+"                         ",24);
  143. 5270  LOCATE ,22:IF T(6,Y)=1 THEN PRINT "ALPHA "; ELSE IF T(6,Y)=2 THEN PRINT "NUMBER"; ELSE IF T(6,Y)=3 THEN PRINT "DATE  "; ELSE IF T(6,Y)=4 THEN PRINT "$$$.$$"; ELSE PRINT "      ";
  144. 5280  PRINT  "     ";BB(6,Y);"              ";BL(6,Y):NEXT:COLOR 7,0
  145. 5290  REM INPUT ROUTINE FOR REVISION
  146. 5300  LOCATE 19,3:COLOR 15:PRINT "PRESENT VALUE IS ======> ":COLOR 7,0
  147. 5310  IF E1<>1 THEN 5410
  148. 5320  LOCATE 19,30:PRINT F$(6)
  149. 5330  LOCATE 21,3: INPUT "ENTER NEW FILE NAME =======> ";AN$:IF AN$<>"" THEN F$(CH)=AN$
  150. 5340  IF LEN(F$(CH))>8 THEN GOSUB 1260:GOTO 5330
  151. 5350  COLOR 9:LOCATE 4,1:PRINT "FILE: ";F$(CH);"     ENTRIES: ";TE(6);"   LENGTH: ";LL(6)"   DRIVE: ";DR$(6):COLOR 7,0
  152. 5360  LOCATE 19,30:PRINT DR$(6);"         "
  153. 5370  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the letter of the drive that will have the data disk.":LOCATE 22,3:INPUT "Type either A or B (or C if you have a hard disk drive) ==> ";AN$: IF AN$<>"" THEN DR$(CH)=AN$
  154. 5380  IF INSTR("abcABC",DR$(CH))=0 THEN GOSUB 1260: GOTO 5370
  155. 5390  IF LEN(DR$(CH))>1 THEN 1260: GOTO 5370
  156. 5400  COLOR 9:LOCATE 4,1:PRINT "FILE: ";F$(CH);"     ENTRIES: ";TE(6);"   LENGTH: ";LL(6)"   DRIVE: ";DR$(CH):COLOR 7,0
  157. 5410  FOR Y=E1 TO E2
  158. 5420  LOCATE 19,30: PRINT T$(6,Y);"       "
  159. 5430  GOSUB 1140: LOCATE 21,3:PRINT "Please type in the title for entry # ";Y" (only 10 spaces please)."
  160. 5440  LOCATE 22,3: PRINT "Title for entry # ";Y;" ";:INPUT AN$: IF AN$="" THEN T$(F,Y)=T$(6,Y) ELSE T$(F,Y)=AN$
  161. 5450  IF LEN(T$(F,Y))>10 THEN GOSUB 1260:GOTO 5430
  162. 5460  LOCATE 6+(Y MOD 11),7:PRINT T$(F,Y);"    ": IF Y <>1 THEN BB(F,Y)=BB(F,Y-1)+BL(F,Y-1) ELSE IF F=0 THEN BB(F,Y)=11 ELSE BB(F,Y)=5
  163. 5470  LOCATE 19,30:PRINT T(6,Y);"         ";:GOSUB 1140: LOCATE 21,3:PRINT "Type of entry: (1) Alphabetic; (2) Number; (3) Date; (4) Dollars/cents": LOCATE 22,3: INPUT "Enter the type of entry ===> ";AN$:IF AN$="" THEN T(F,Y)=T(6,Y) ELSE T(F,Y)= VAL(AN$)
  164. 5480  IF T(F,Y)<1 OR T(F,Y)>4 THEN GOSUB 1260: GOTO 5470
  165. 5490  LOCATE 6+(Y MOD 11),22:PRINT MID$("ALPHA NUMBERDATE  00.00 ",1+((T(F,Y)-1)*6),6);
  166. 5495  IF T(F,Y)=3 THEN BL(F,Y)=6: GOTO 5530
  167. 5500  LOCATE 19,30:PRINT BL(6,Y);"     ":GOSUB 1140: LOCATE 21,3:PRINT "Please type in the maximum number of spaces you wish reserved for this ": LOCATE 22,3: INPUT "entry ====> ";AN$:IF AN$<>"" THEN BL(F,Y)=VAL(AN$) ELSE BL(F,Y)=BL(6,Y)
  168. 5510  IF BL(F,Y)<>BL(6,Y) THEN REWRITE=1
  169. 5520  IF BL(F,Y)=0 THEN LOCATE 6+(Y MOD 11),52:PRINT "DELETED":DFLAG=1:GOTO 5540
  170. 5530  LOCATE 6+(Y MOD 11),33:PRINT BB(F,Y);:LOCATE ,51:PRINT BL(F,Y)
  171. 5540  TE(F)=TE(F)+1:LL(F)=LL(F)+BL(F,Y)
  172. 5550  NEXT Y
  173. 5560  IF Y-1=>TE(6) THEN GOSUB 1140: LOCATE 21,3:BEEP:BEEP:INPUT "Do you want to add an entry (Y/N) ";AN$: IF LEFT$(AN$,1)="Y" OR LEFT$(AN$,1)="y" THEN E1=Y: E2=E1:GOTO 5250 ELSE 5580
  174. 5570  GOTO 5230
  175. 5580  LL(F)=LL(F)+1
  176. 5590  COLOR 9:LOCATE 4,1:PRINT "FILE: ";F$(CH);"     ENTRIES: ";TE(CH);"   LENGTH: ";LL(CH)"   DRIVE: ";DR$(CH):COLOR 7,0
  177. 5600  GOSUB 1140: LOCATE 21,3: BEEP:PRINT "CONFIRMATION: Do you wish to make any corrections before this is":LOCATE 22,3: INPUT "written to the disk (Y/N) ";AN$: IF LEFT$(AN$,1)="Y" OR LEFT$(AN$,1)="y" THEN 5170
  178. 5610  F=TF:IF DFLAG=0 AND REWRITE=0 THEN GOSUB 3490:RUN
  179. 5620  IF DFLAG=1 AND REWRITE=0 THEN GOSUB 9000:
  180. 5630   ON ERROR GOTO 5640: OPEN F$(6) FOR INPUT AS #6: INPUT #6,X$:ON ERROR GOTO 0:GOTO 5650
  181. 5640  IF DFLAG=1 AND REWRITE =0 THEN RUN ELSE GOSUB 9000:RUN: REM TAKES CARE OF DFLAG/REWRITE 1/0 AND 1/1 AND 0/1
  182. 5650  CLOSE
  183. 5660  REM NOW REWRITE FILE
  184. 5670  GOSUB 1120:GOSUB 1160:
  185. 5680  LOCATE 6,1:COLOR 9:PRINT "INSTRUCTIONS BEFORE RE-WRITING OF FILE":COLOR 7,0
  186. 5690  PRINT "BEFORE the file is re-written, the computer needs to know what to do with the   new file formats that are usually written to the format file."
  187. 5700  LOCATE 21,3: BEEP:INPUT "Should the new file formats be written into the format file (Y/N)";AN$:IF LEFT$(AN$,1)="Y" OR LEFT$(AN$,1)="y" THEN FORMAT =1
  188. 5710  GOSUB 1140
  189. 5720  IF FORMAT=1 THEN GOSUB 9000
  190. 5730  GOSUB 1120:COLOR 15: LOCATE 6,1: PRINT "OLD FILE =====> ":LOCATE 8,1:PRINT "NEW FILE =====> ":LOCATE 10,1: IF DFLAG=1 THEN PRINT "SOME FIELDS ARE DELETED" ELSE PRINT "NO DELETED FIELDS"
  191. 5740  LOCATE 12,1: IF REWRITE=0 THEN PRINT "NO FIELD LENGTHS ARE CHANGED" ELSE PRINT "SOME FIELD LENGTHS ARE CHANGED"
  192. 5750  IF F$(CH)=F$(6) THEN F$(6)= F$(6)+".OLD"
  193. 5760  LOCATE 6,30:PRINT F$(6);"      DRIVE: ";DR$(6)
  194. 5770  LOCATE 8,30:PRINT F$(CH);"      DRIVE: ??"
  195. 5780  LOCATE 21,3:BEEP:INPUT "WHICH DRIVE WILL CONTAIN THE DISK FOR THE NEW FILE (A-C) ";DR$: IF INSTR("AaBbCc",DR$)=0 THEN GOSUB 1260:GOTO 5780
  196. 5790  LOCATE 8,30:PRINT F$(CH);"      DRIVE: ";DR$;"       "
  197. 5800  LOCATE 22,3:BEEP:BEEP:COLOR 31:INPUT "INSERT DISKS AND PRESS THE 'ENTER' KEY ";AN$:COLOR 7,0
  198. 5810  GOSUB 1140: LOCATE 22,3:PRINT "NOW TRANSFERRING RECORD # "
  199. 5820  OF$=DR$(6)+":"+F$(6):REM OLD FILE
  200. 5830  QQ=4:IF CH=0 THEN QQ=10
  201. 5835  QZ=QQ:OPEN OF$ AS #1 LEN=LL(6):FIELD #1,QZ AS P$(1)
  202. 5840  FOR Y=1 TO TE(6): IF QZ>510 THEN FIELD #1,255 AS Q1$,255 AS Q2$,QZ-510 AS Q3$,BL(6,Y) AS X$(1,Y) ELSE IF QZ>255 THEN FIELD #1,255 AS Q1$,QZ-255 AS Q2$,BL(6,Y) AS X$(1,Y) ELSE IF QZ=<255 THEN FIELD #1,QZ AS Q1$,BL(6,Y) AS X$(1,Y)
  203. 5850  QZ=QZ+BL(6,Y):NEXT
  204. 5860  NF$=DR$(CH)+":"+F$(CH): REM NEW FILE
  205. 5870  QZ=QQ:OPEN NF$ AS #2 LEN=LL(CH):FIELD #2,QZ AS P$(CH)
  206. 5880  FOR Y=1 TO TE(CH): IF QZ>510 THEN FIELD #2,255 AS W1$,255 AS W2$,QZ-510 AS W3$,BL(CH,Y) AS X$(2,Y) ELSE IF QZ>255 THEN FIELD #2,255 AS W1$,QZ-255 AS W2$,BL(CH,Y) AS X$(2,Y) ELSE IF QZ=<255 THEN FIELD #2,QZ AS W1$,BL(CH,Y) AS X$(2,Y)
  207. 5890  QZ=QZ+BL(CH,Y):NEXT
  208. 5900  FOR X=1 TO 9999: IF EOF(1) THEN 5950
  209. 5910  LOCATE 22,25:PRINT X
  210. 5920  GET #1: Y1=0:FOR Y=1 TO TE(6): IF BL(6,Y)<>0 THEN Y1=Y1+1: LSET X$(2,Y1)=X$(1,Y):
  211. 5930  NEXT: PUT #2
  212. 5940  NEXT
  213. 5950  CLOSE:RUN
  214. 6000  REM DELETE SUB-FILE
  215. 6010  GOSUB 1120
  216. 6020  GOSUB 1170:GOSUB 1160                                                    
  217. 6030  COLOR 9: LOCATE 6,1: PRINT "DELETION OF SUB-FILE":COLOR 7,0
  218. 6040  LOCATE 8,1: PRINT "This routine will delete any sub-file that you choose. Currently you have these sub-files:"
  219. 6050  LOCATE 10,15: FOR G=1 TO F-1:LOCATE ,15:PRINT G".  ";F$(G):NEXT
  220. 6060  LOCATE 21,3:PRINT "Type the number of the sub-file you wish to delete "
  221. 6070  LOCATE 22,3:INPUT "Number of sub-file to DELETE ===> ";AN$:D=VAL(AN$)
  222. 6080  IF D>F-1 THEN GOSUB 1260:GOTO 6060
  223. 6090  IF D=0 THEN RUN
  224. 6100  GOSUB 1140
  225. 6110  LOCATE 21,3:PRINT "To confirm the deletion you must type the name of the sub-file: ";F$(D)
  226. 6120  LOCATE 22,3:INPUT "Name of Sub-File to delete ====> ";AN$
  227. 6130  IF AN$<>F$(D) THEN LOCATE 23,3:PRINT "ACCESS DENIED":GOSUB 1250:RUN
  228. 6140  GOSUB 1140
  229. 6150  IF AN$=F$(D) THEN LOCATE 21,3:PRINT "ACCESS GAINED":GOSUB 1250
  230. 6160  LOCATE 22,3: COLOR 31: PRINT "DELETING SUB-FILE":COLOR 7,0
  231. 6170  FOR F=D TO F-1:SWAP F$(F),F$(F+1):SWAP LL(F),LL(F+1):SWAP TE(F),TE(F+1):SWAP DR$(F),DR$(F+1): FOR Y=1 TO TE(F):SWAP T$(F,Y),T$(F+1,Y):SWAP T(F,Y),T(F+1,Y):SWAP BB(F,Y),BB(F,Y+1):SWAP BL(F,Y),BL(F,Y+1):NEXT:NEXT: F=F-1
  232. 6180  KILL F$
  233. 6190  OPEN F$ FOR OUTPUT AS #7: FE=F: FOR F=0 TO FE-1: PRINT #7,F$(F):PRINT#7,LL(F):PRINT#7,TE(F):PRINT #7,DR$(F):FOR Y=1 TO TE(F):PRINT #7,T$(F,Y):PRINT#7,T(F,Y):PRINT#7,BB(F,Y):PRINT#7,BL(F,Y):NEXT:NEXT
  234. 6200  LOCATE 22,3:COLOR 31:PRINT "ERASING POINTERS IN MASTER FILE TO DELETED SUB-FILE":COLOR 7,0
  235. 6210  OPEN F$(0) AS #1 LEN=LL(0)
  236. 6220  FIELD #1,10 AS P$
  237. 6230  FOR X=1 TO 9999: LOCATE 22,70:PRINT X
  238. 6240  GET #1,X
  239. 6250  IF EOF(1) THEN 6310
  240. 6260  FOR Y=D TO 5:
  241. 6270  LSET P$=MID$(P$,1,Y*2)+MID$(P$,(Y+1)*2)+MKI$(0)
  242. 6280  NEXT
  243. 6290  PUT #1,X
  244. 6300  NEXT
  245. 6310  CLOSE
  246. 6320  FI$=DR$+":REC":OPEN FI$ FOR INPUT AS #7:IF EOF(7)THEN 6340
  247. 6330  FOR G=0 TO TF:INPUT#7,NR(G),DL(G):NEXT
  248. 6340  CLOSE#7:NR(D)=0:DL(D)=0:FI$=DR$+":REC":OPEN FI$ FOR OUTPUT AS #7:FOR G=0 TO TF:WRITE#7,NR(G),DL(G):NEXT:CLOSE#7:RUN
  249. 7000  REM PRINT FILE FORMAT
  250. 7010  GOSUB 1120:GOSUB 1160:GOSUB 1170
  251. 7020  COLOR 9:LOCATE 6,1:PRINT "PRINTING OF FORMAT FILE":COLOR 7,0
  252. 7030  LOCATE 8,1: COLOR 18: PRINT "TURN ON PRINTER NOW":COLOR 7,0
  253. 7040  LOCATE 21,3:COLOR 18: PRINT "TURN ON PRINTER NOW!":COLOR 7,0
  254. 7050  LOCATE 10,1:PRINT "This routine will print out the format file.  It is important to keep this      information on file.  This information may be needed when you wish to sort"
  255. 7060  PRINT "or change/alter the files."
  256. 7070  LOCATE 23,3:INPUT "PRESS THE 'ENTER' KEY TO BEGIN ";AN$
  257. 7080  LPRINT "FILE FORMATS  ON ";DATE$:LPRINT:LPRINT
  258. 7090  FE=F-1: FOR F=0 TO FE: IF F=0 THEN LPRINT "MASTER FILE ======> ";F$(0); ELSE LPRINT "FILE ==========> "F$(F);
  259. 7100  LPRINT "     LENGTH: ";LL(F);"   ENTRIES  ";TE(F);"    DRIVE: ";DR$(F):LPRINT
  260. 7110  LPRINT "#     TITLE          TYPE     BEGINNING         LENGTH"
  261. 7120  FOR Y=1 TO TE(F):LPRINT Y".  ";LEFT$(T$(F,Y)+"                  ",15);
  262. 7130  IF T(F,Y)=1 THEN LPRINT "ALPHA "; ELSE IF T(F,Y)=2 THEN LPRINT "NUMBER"; ELSE IF T(F,Y)=3 THEN LPRINT "DATE  "; ELSE IF T(F,Y)=4 THEN LPRINT "$$$.$$";
  263. 7140  LPRINT  "     ";BB(F,Y);"              ";BL(F,Y):NEXT
  264. 7150  LPRINT " ":LPRINT " ":NEXT: RUN
  265. 8000  REM EXIT
  266. 8010  RUN "MENU"
  267. 9000  REM REWRITE OF FORMAT FILE
  268. 9010  LOCATE 22,3:GOSUB 1140:PRINT "WRITING NEW FORMAT FILE":F=TF:
  269. 9020  TE=0:LL=4+((CH=0)*-6):F=TF:FOR Y=1 TO TE(CH):TE=TE+1:LL=LL+BL(CH,Y):IF BL(CH,Y)=0 THEN TE=TE-1:LL=LL-BL(CH,Y)
  270. 9030  NEXT Y: LL=LL+1:REM NOW HAVE NEW NUMBER OF ENTRIES FOR FORMAT FILE
  271. 9040  OPEN F$ FOR OUTPUT AS #7: FE=F: FOR F=0 TO TF:
  272. 9050  IF F<>CH THEN PRINT #7,F$(F):PRINT#7,LL(F):PRINT#7,TE(F):PRINT #7,DR$(F):FOR Y=1 TO TE(F):PRINT #7,T$(F,Y):PRINT#7,T(F,Y):PRINT#7,BB(F,Y):PRINT#7,BL(F,Y):NEXT
  273. 9060  IF F=CH THEN PRINT #7,F$(F):PRINT#7,LL:PRINT#7,TE:PRINT #7,DR$(F):FOR Y=1 TO TE(F):IF BL(F,Y)<>0 THEN PRINT #7,T$(F,Y):PRINT#7,T(F,Y):PRINT#7,BB(F,Y):PRINT#7,BL(F,Y)
  274. 9070  IF F=CH THEN NEXT
  275. 9080  NEXT F:PRINT #7,CHR$(26):CLOSE
  276. 9090  RETURN
  277. 10000  OLDROW=CSRLIN:OLDCOL=POS(0):LOCATE 2,3:PRINT TIME$:LOCATE OLDROW,OLDCOL:RETURN
  278. 30000  OLDROW=CSRLIN:OLDCOL=POS(0):OPEN "ERROR" AS #7 LEN=176:FIELD #7,35 AS ER$(1),70 AS ER$(2),70 AS ER$(3):GET#7,ERR
  279. 30010  LOCATE 20,3:PRINT LEFT$(ER$(1),INSTR(ER$(1),"  ")+(-40*INSTR(ER$(1),"  ")=0));" IN LINE ";ERL;" (Press any key)":LOCATE 21,3:PRINT ER$(2):LOCATE 22,3:PRINT ER$(3):PLAY"MB":J9=2:FOR I9=1 TO 9:PLAY"L64T255O=J9;CC#DD#EFF#GG#AA#B":NEXT
  280. 30020  AE$=INKEY$:IF AE$=""THEN 30020 ELSE FOR EL=20 TO 22:LOCATE EL,3:PRINT STRING$(76,32);:NEXT:LOCATE OLDROW,OLDCOL:CLOSE#7:RESUME
  281. 40000  REM **********************************************************
  282. 40010  REM **********************************************************
  283. 40020  REM ** COPYRIGHT (C) 1984 GERALD E. GONDERINGER             **
  284. 40030  REM ** The Omaha DataBase Program                           **
  285. 40040  REM ** $50.00 REGISTRATION FEE FOR USE OF PROGRAM           **
  286. 40050  REM **********************************************************
  287. 40060  REM **********************************************************
  288. 40070  CLS:COLOR 15,0:LOCATE 10,20:PRINT"*****  ADAPTATIONS ROUTINE *****":BEEP:COLOR 7,0:LOCATE 15,20:PRINT"** ENTER PASS CODE TO PROCEED **":DEF SEG:POKE &H6A,0:DEF SEG=0:POKE 1052,PEEK(1050)
  289. 40080  K$=INKEY$:IF K$=""THEN 40080 ELSE IF K$="G"OR K$="g"THEN 40090 ELSE 40110
  290. 40090  DEF SEG:POKE 1124,0:CHAIN MERGE"ADD",40095
  291. 40100  SAVE "A:CREATE"
  292. 40110  RUN"MENU
  293. 55222  E1=E2+1:
  294.